There are two levels worth analyzing in response to this question – trends by species and by intake types. This first figure shows the monthly intake per species across the date range of the provided data, January to August 2020.
# Produce a data-frame with counts for each species, per month
var <- 'species'
by_month <- foo %>%
mutate(fact_in = factor(!!sym(var), levels=rev(c('Dog', 'Cat', 'Other')))) %>%
mutate(Time = format(as.Date(intake_date), "%Y-%m")) %>%
group_by(Time, fact_in, .drop=FALSE) %>%
summarise(n = length(fact_in), .groups='drop_last')
# generate barplot
p<-ggplot(by_month, aes(x=Time, y=n, group=fact_in, fill=fact_in, text=paste('Count:', n)))+
geom_col(alpha=0.6 , size=0.5, colour="black", position='dodge')+
theme(panel.border=element_rect(colour="black", fill= NA)) +
theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))+
labs(y = 'Count') +
scale_fill_discrete(name = "Species")
# make interactive
ggplotly(p, tooltip=c('text')) %>% config(displayModeBar = FALSE)
The figure shows a downward trend in dog intake from 1189 in January to a low of 457 in April, staying similarly low in May and June before moderately increasing again in July and August. Presumably, this can be associated with the rise of Covid-19, but more context is needed about the shelter’s policies and the situation in Tuscon to say anything more specific. Cat intake similarly decreased from 390 in January to a low of 182 in April, but remained fairly stable (256-271) between May and August. Other species have much lower numbers; a notable month is June, which peaked with 93 animals, almost twice as much as the second-highest ‘Others’ intake in January (51).
The second level worth visualizing is intake type. I think this is better examined separately for dogs and cats, since looking at them together might overlook trends that cancel each other out on the aggregate (for example, a decrease in stray dogs and increase in stray cats would appear as no change in stray intake).
The following figure shows the number of dogs under the four most prevalent intake types per month. For better readability, I left out rare intake types: Quarantine, Return (which I looked at separately, and they were stable), Pub Assist and Transfer. Note that you can click on the legend to hide/show each category.
# very simiar to the above, but for intake type rather than species
absolute_intake_type <- function(spec){
var <- 'src_intake_type'
# show only the top four intake types
four_types <- c('DISPO REQ', 'CONFISCATE', 'OWNER SUR', 'STRAY')
# create dataframe with per-month counts
by_month <- foo %>% filter(species == spec) %>% filter(src_intake_type %in% four_types) %>%
mutate(fact_in = factor(!!sym(var), levels=four_types)) %>%
mutate(Time = format(as.Date(intake_date), "%Y-%m")) %>%
group_by(Time, fact_in, .drop=FALSE) %>%
summarise(n = length(fact_in), .groups='drop_last')
# generate bar plot
p <- ggplot(by_month, aes(x=Time, y=n, group=fact_in, fill=fact_in, text=paste('Count:',n)))+
geom_col(alpha=0.6 , size=0.5, colour="black", position='dodge')+
theme(panel.border=element_rect(colour="black", fill= NA)) +
theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))+
labs(y = 'Count') +
scale_fill_discrete(name = "Intake Type")
# make interactive
return (ggplotly(p, tooltip = 'text') %>% config(displayModeBar = FALSE))
}
# plot for dogs
absolute_intake_type('Dog')
A few things stand out for dog intakes:
The following figure is similar, but for cats:
# plot for cats
absolute_intake_type('Cat')
We see some similarities and differences here:
When looking at all species together, Tuesday and Wednesday have slightly higher volumes than other days.
# add the weekday variable
foo$weekday <- weekdays(foo$intake_date)
# Change ordering manually
foo$weekday_ord <- factor(foo$weekday,
levels = c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday"))
# function for plotting
day_volume <- function(foo){
# data frame to plot
plot_data <- foo %>% count(weekday_ord)
# generate plot
ggplot(plot_data) + geom_col(aes(x = weekday_ord, y=n)) +
labs(x = 'Day', y = 'Count')+
geom_text(aes(x = weekday_ord, label = sprintf("%.f", n), y= n), vjust=2, colour="white", size=4)
}
# plot for all species
day_volume(foo)
When looking at dogs only, they are still higher, but the trend is not apparent. Sunday is relatively lower.
# plot for dogs
day_volume(foo %>% filter(species == 'Dog'))
Which suggest that for cats we will see it more distinctly, as indeed this figure shows. More specifically, Wednesday is cat day (Thursday following), as Tuesday is calmer than all other days.
# plot for cats
day_volume(foo %>% filter(species == 'Cat'))
The missing values, in decreasing order:
Here’s a heat-map showing the number of Found animals per ZIP code! A few ZIP codes in the center of the city stand out and numbers relatively decrease in the outskirts. 85705 and 85706 also stand out as fairly smaller ZIP codes with high intakes (although presumably with a denser population). 114 animals also came from way outside town (85321 - a different shelter?).
# load ZIP codes geometry
geometry <- readRDS('zips.rds')
# count finders per ZIP code (did not plot that for simplicity)
finder_count <- foo %>% filter(src_finders_zip_code!=0) %>% group_by(zip=src_finders_zip_code) %>%
summarise(count = length(src_finders_zip_code), .groups='keep')
# count found per ZIP code
found_count <- foo %>% group_by(zip=src_found_zip_code) %>%
summarise(count = length(src_found_zip_code), .groups='keep')
# merge the counts and name properly
countDF <- inner_join(finder_count,found_count, by='zip')
colnames(countDF) = c('zip', 'countFinder', 'countFound')
countDF$zip = as.character(countDF$zip)
# merge with the ZIP code geometry
count_sf <- geometry %>% inner_join(countDF, by = "zip")
fix_sf <- function(old_sf){
# transform the shapefile to the correct projection to make leaflet happy
return(st_transform(old_sf, '+proj=longlat +datum=WGS84'))
}
# create color palette
pal <- colorBin(palette='Purples', domain = count_sf$countFound, bins = c(0, 50, 100, 200, 500, 1000))
# create tooltip label
label <- sprintf("<strong>%s</strong><br/>%g %s", count_sf$zip, count_sf$countFound, 'Found Animals') %>%
lapply(htmltools::HTML)
# create map
leaflet() %>%
addTiles() %>%
setView(lat = 32.2239217, lng = -110.917225, zoom=8) %>%
addPolygons(data=fix_sf(count_sf), group='Found', fillColor=~pal(countFound),
fillOpacity = 0.7, color='grey', weight = 1, opacity = 0.4, label = label,
highlightOptions = highlightOptions(color = "black",weight = 2, bringToFront = TRUE)) %>%
addLegend(pal = pal, values = count_sf$countFound, opacity = 0.7, title = 'Found Animals',
position = "bottomright", group='Found')